home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / file-part.el.z / file-part.el
Encoding:
Text File  |  1998-05-21  |  9.8 KB  |  274 lines
  1. ;;; file-part.el --- treat a section of a buffer as a separate file
  2.  
  3. ;; Keywords: extensions, tools
  4.  
  5. ;; Copyright (C) 1992-1993 Sun Microsystems.
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Synched up with: Not in FSF.
  25.  
  26. ;; Written by Ben Wing.
  27.  
  28. (provide 'file-part)
  29.  
  30. (define-error 'file-part-error "File part error" 'file-error)
  31.  
  32. (defvar file-part-extent-alist nil
  33.   "Alist of file parts in the current buffer.
  34. Each element of the alist maps an extent describing the file part
  35. to the buffer containing the file part.  DON'T MODIFY THIS.")
  36. (make-variable-buffer-local 'file-part-extent-alist)
  37. (setq-default file-part-extent-alist nil)
  38.  
  39. (defvar file-part-master-extent nil
  40.   "Extent this file part refers to in the master buffer.
  41. NIL if this buffer is not a file part.  The master buffer itself
  42. can be found by calling `extent-buffer' on this extent.
  43. DON'T MODIFY THIS.")
  44. (make-variable-buffer-local 'file-part-master-extent)
  45. (setq-default file-part-master-extent nil)
  46.  
  47. (or (assq 'file-part-master-extent minor-mode-alist)
  48.     (setq minor-mode-alist
  49.       (cons minor-mode-alist
  50.         '((file-part-master-extent " File-part")))))
  51.  
  52. ; apply a function to each element of a list and return true if
  53. ; any of the functions returns true.
  54. (defun file-part-maptrue (fn list)
  55.   (cond ((null list) nil)
  56.     ((funcall fn (car list)))
  57.     (t (file-part-maptrue fn (cdr list)))))
  58.  
  59. ; return a buffer to operate on.  If NIL is specified, this is the
  60. ; current buffer.  If a string is specified, this is the buffer with
  61. ; that name.
  62. (defun file-part-buffer-from-arg (arg)
  63.   (get-buffer (or arg (current-buffer))))
  64.  
  65. ;;;###autoload
  66. (defun make-file-part (&optional start end name buffer)
  67.   "Make a file part on buffer BUFFER out of the region.  Call it NAME.
  68. This command creates a new buffer containing the contents of the
  69. region and marks the buffer as referring to the specified buffer,
  70. called the `master buffer'.  When the file-part buffer is saved,
  71. its changes are integrated back into the master buffer.  When the
  72. master buffer is deleted, all file parts are deleted with it.
  73.  
  74. When called from a function, expects four arguments, START, END,
  75. NAME, and BUFFER, all of which are optional and default to the
  76. beginning of BUFFER, the end of BUFFER, a name generated from
  77. BUFFER's name, and the current buffer, respectively."
  78.   (interactive "r\nsName of file part: ")
  79.   (setq buffer (file-part-buffer-from-arg buffer))
  80.   (if (null start) (setq start (point-min)))
  81.   (if (null end) (setq end (point-max)))
  82.   (if (null name) (setq name (concat (buffer-name buffer) "-part")))
  83.   (if (> start end) nil
  84.     (set-buffer buffer)
  85.     (make-local-variable 'write-contents-hooks)
  86.     (make-local-variable 'kill-buffer-hook)
  87.     (make-local-variable 'revert-buffer-function)
  88.     (add-hook 'write-contents-hooks 'write-master-buffer-hook)
  89.     (add-hook 'kill-buffer-hook 'kill-master-buffer-hook)
  90.     (setq revert-buffer-function 'revert-master-buffer-function)
  91.     (if (file-part-maptrue (function (lambda (x)
  92.                  (let ((b (extent-start-position (car x)))
  93.                    (e (extent-end-position (car x))))
  94.                    (and
  95.                 (numberp b)
  96.                 (numberp e)
  97.                 (not (or (and (<= b start) (<= e start))
  98.                      (and (>= b end) (>= e end))))))))
  99.          file-part-extent-alist)
  100.     (signal 'file-part-error (list "Overlapping file parts not allowed"
  101.                        buffer))
  102.       (let ((x (make-extent start end))
  103.          (filebuf (generate-new-buffer name)))
  104.     (set-extent-property x 'read-only t)
  105.     (setq file-part-extent-alist
  106.           (cons (cons x filebuf) file-part-extent-alist))
  107.     (switch-to-buffer filebuf)
  108.         (setq buffer-file-name (concat "File part on " (buffer-name buffer)))
  109.         (make-local-variable 'write-file-hooks)
  110.         (make-local-variable 'kill-buffer-hook)
  111.     (make-local-variable 'revert-buffer-function)
  112.     (make-local-variable 'first-change-hook)
  113.         (add-hook 'write-file-hooks 'write-file-part-hook)
  114.         (add-hook 'kill-buffer-hook 'kill-file-part-hook)
  115.     (setq revert-buffer-function 'revert-file-part-function)
  116.     (setq file-part-master-extent x)
  117.     (insert-buffer-substring buffer start end)
  118.     ; do this after inserting the text so the master buffer isn't marked as
  119.     ; modified.
  120.     (add-hook 'first-change-hook 'file-part-first-change-hook)
  121.         (set-buffer-modified-p nil)
  122.     filebuf))))
  123.  
  124. (defun kill-file-part-hook ()
  125.   "Hook to be called when a file-part buffer is killed.
  126. Removes the file part from the master buffer's list of file parts."
  127.   (let ((x file-part-master-extent)
  128.     (buf (current-buffer)))
  129.     (if x (save-excursion
  130.         (set-buffer (extent-buffer x))
  131.         (setq file-part-extent-alist
  132.           (delete (cons x buf) file-part-extent-alist))
  133.         (delete-extent x)))))
  134.  
  135. (defun kill-all-file-parts (&optional bufname no-ask)
  136.   "Kill all file parts on buffer BUFNAME.
  137. The argument may be a buffer or the name of a buffer.
  138. If one or more of the file parts needs saving, prompts for
  139. confirmation unless optional second argument NO-ASK is non-nil.
  140. BUFFER defaults to the current buffer if not specified."
  141.   (interactive "b")
  142.   (setq bufname (file-part-buffer-from-arg bufname))
  143.   (save-excursion
  144.     (set-buffer bufname)
  145.     (and (or no-ask
  146.          (not (file-parts-modified-p bufname))
  147.          (y-or-n-p "Buffer has modified file parts; kill anyway? "))
  148.      (mapcar (function (lambda (x)
  149.                  (set-buffer (cdr x))
  150.                  (set-buffer-modified-p nil)
  151.                  (kill-buffer (cdr x))))
  152.          file-part-extent-alist))))
  153.  
  154. (defun kill-master-buffer-hook ()
  155.   "Hook to be called when a master buffer is killed.
  156. Kills the associated file parts."
  157.   (kill-all-file-parts (current-buffer) t))
  158.  
  159. (defun file-part-check-attached (x)
  160.   (cond ((null x) nil)
  161.     ((extent-property x 'detached)
  162.      (kill-file-part-hook)
  163.      (setq buffer-file-name nil)
  164.      (setq file-part-master-extent nil)
  165.      (message "File part has become detached.")
  166.      nil)
  167.     (t)))
  168.  
  169. (defun write-file-part-hook ()
  170.   "Hook to be called when a file part is saved.
  171. Saves the file part into the master buffer."
  172.   (let ((x file-part-master-extent)
  173.     (buf (current-buffer))
  174.     (len (- (point-max) (point-min)))
  175.     (retval (not (null file-part-master-extent))))
  176.     (and (file-part-check-attached x)
  177.      (let ((b (extent-start-position x))
  178.            (e (extent-end-position x)))
  179.        (save-excursion
  180.          (set-buffer (extent-buffer x))
  181.          (set-extent-property x 'read-only nil)
  182.          (goto-char b)
  183.          (insert-buffer-substring buf)
  184.          (delete-region (+ len b) (+ len e))
  185.          (set-extent-property x 'read-only t)
  186.          (set-buffer buf)
  187.          (set-buffer-modified-p nil)
  188.          (message "Wrote file part %s on %s"
  189.               (buffer-name buf)
  190.               (buffer-name (extent-buffer x)))
  191.          t)))
  192.     retval))
  193.  
  194. (defun write-master-buffer-hook ()
  195.   "Hook to be called when a master buffer is saved.
  196. If there are modified file parts on the buffer, optionally
  197. saves the file parts back into the buffer."
  198.   (save-some-file-part-buffers)
  199.   nil)
  200.  
  201. (defun save-some-file-part-buffers (&optional arg buffer)
  202.   "Save some modified file-part buffers on BUFFER.  Asks user about each one.
  203. Optional argument (the prefix) non-nil means save all with no questions.
  204. BUFFER defaults to the current buffer if not specified."
  205.   (interactive "p")
  206.   (setq buffer (file-part-buffer-from-arg buffer))
  207.   (let ((alist file-part-extent-alist)
  208.     (name (buffer-name buffer)))
  209.     (while alist
  210.       (let ((buf (cdr (car alist))))
  211.     (and (buffer-modified-p buf)
  212.          (or arg
  213.          (y-or-n-p (format "Save file part %s on %s? "
  214.                    (buffer-name buf) (buffer-name buffer))))
  215.          (condition-case ()
  216.          (save-excursion
  217.            (set-buffer buf)
  218.            (save-buffer))
  219.            (error nil))))
  220.       (setq alist (cdr alist)))))
  221.  
  222. (defun file-parts-modified-p (&optional buffer)
  223.   "Return true if BUFFER has any modified file parts on it.
  224. BUFFER defaults to the current buffer if not specified."
  225.   (save-excursion
  226.     (and buffer (set-buffer buffer))
  227.     (file-part-maptrue (function (lambda (x) (buffer-modified-p (cdr x))))
  228.                file-part-extent-alist)))
  229.  
  230. (defun revert-file-part-function (&optional check-auto noconfirm)
  231.   "Hook to be called when a file part is reverted.
  232. Reverts the file part from the master buffer."
  233.   (let ((x file-part-master-extent))
  234.     (and (file-part-check-attached x)
  235.      (let ((master (extent-buffer x)))
  236.        (and
  237.         (or noconfirm
  238.         (yes-or-no-p
  239.          (format
  240.           "Revert file part from master buffer %s? "
  241.           (buffer-name master))))
  242.         (progn
  243.           (erase-buffer)
  244.           (let ((mod (buffer-modified-p master)))
  245.         (insert-buffer-substring master
  246.                      (extent-start-position x)
  247.                      (extent-end-position x))
  248.         (set-buffer-modified-p nil)
  249.         (save-excursion
  250.           (set-buffer master)
  251.           (set-buffer-modified-p mod)))))))))
  252.  
  253. (defun revert-master-buffer-function (&optional check-auto noconfirm)
  254.   "Hook to be called when a master-buffer is reverted.
  255. Makes sure the user is aware that the file parts will become detached,
  256. then proceeds as normal."
  257.   (or noconfirm
  258.       (null file-part-extent-alist)
  259.       (progn
  260.     (message "Warning: file parts will become detached.")
  261.     (sleep-for 2)))
  262.   (let ((revert-buffer-function nil))
  263.     (revert-buffer (not check-auto) noconfirm)))
  264.  
  265. (defun file-part-first-change-hook ()
  266.   "Hook to be called when a file part is first modified.
  267. Marks the master buffer as modified."
  268.   (let ((x file-part-master-extent))
  269.     (and (file-part-check-attached x)
  270.      (save-excursion
  271.        (set-buffer (extent-buffer x))
  272.        (set-buffer-modified-p t)))))
  273.  
  274.